home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / lib / perl / 5.10.0 / B.pm < prev    next >
Encoding:
Perl POD Document  |  2008-07-24  |  7.7 KB  |  322 lines
  1. #      B.pm
  2. #
  3. #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
  4. #
  5. #      You may distribute under the terms of either the GNU General Public
  6. #      License or the Artistic License, as specified in the README file.
  7. #
  8. package B;
  9.  
  10. our $VERSION = '1.17';
  11.  
  12. use XSLoader ();
  13. require Exporter;
  14. @ISA = qw(Exporter);
  15.  
  16. # walkoptree_slow comes from B.pm (you are there),
  17. # walkoptree comes from B.xs
  18. @EXPORT_OK = qw(minus_c ppname save_BEGINs
  19.         class peekop cast_I32 cstring cchar hash threadsv_names
  20.         main_root main_start main_cv svref_2object opnumber
  21.         sub_generation amagic_generation perlstring
  22.         walkoptree_slow walkoptree walkoptree_exec walksymtable
  23.         parents comppadlist sv_undef compile_stats timing_info
  24.         begin_av init_av check_av end_av regex_padav dowarn defstash
  25.         curstash warnhook diehook inc_gv @optype @specialsv_name
  26.         );
  27. push @EXPORT_OK, qw(unitcheck_av) if $] > 5.009;
  28.  
  29. sub OPf_KIDS ();
  30. use strict;
  31. @B::SV::ISA = 'B::OBJECT';
  32. @B::NULL::ISA = 'B::SV';
  33. @B::PV::ISA = 'B::SV';
  34. @B::IV::ISA = 'B::SV';
  35. @B::NV::ISA = 'B::SV';
  36. @B::RV::ISA = 'B::SV';
  37. @B::PVIV::ISA = qw(B::PV B::IV);
  38. @B::PVNV::ISA = qw(B::PVIV B::NV);
  39. @B::PVMG::ISA = 'B::PVNV';
  40. # Change in the inheritance hierarchy post 5.9.0
  41. @B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
  42. # BM is eliminated post 5.9.5, but effectively is a specialisation of GV now.
  43. @B::BM::ISA = $] > 5.009005 ? 'B::GV' : 'B::PVMG';
  44. @B::AV::ISA = 'B::PVMG';
  45. @B::GV::ISA = 'B::PVMG';
  46. @B::HV::ISA = 'B::PVMG';
  47. @B::CV::ISA = 'B::PVMG';
  48. @B::IO::ISA = 'B::PVMG';
  49. @B::FM::ISA = 'B::CV';
  50.  
  51. @B::OP::ISA = 'B::OBJECT';
  52. @B::UNOP::ISA = 'B::OP';
  53. @B::BINOP::ISA = 'B::UNOP';
  54. @B::LOGOP::ISA = 'B::UNOP';
  55. @B::LISTOP::ISA = 'B::BINOP';
  56. @B::SVOP::ISA = 'B::OP';
  57. @B::PADOP::ISA = 'B::OP';
  58. @B::PVOP::ISA = 'B::OP';
  59. @B::LOOP::ISA = 'B::LISTOP';
  60. @B::PMOP::ISA = 'B::LISTOP';
  61. @B::COP::ISA = 'B::OP';
  62.  
  63. @B::SPECIAL::ISA = 'B::OBJECT';
  64.  
  65. @B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
  66. # bytecode.pl contained the following comment:
  67. # Nullsv *must* come first in the following so that the condition
  68. # ($$sv == 0) can continue to be used to test (sv == Nullsv).
  69. @B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no
  70.             (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
  71.  
  72. {
  73.     # Stop "-w" from complaining about the lack of a real B::OBJECT class
  74.     package B::OBJECT;
  75. }
  76.  
  77. sub B::GV::SAFENAME {
  78.   my $name = (shift())->NAME;
  79.  
  80.   # The regex below corresponds to the isCONTROLVAR macro
  81.   # from toke.c
  82.  
  83.   $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
  84.     chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
  85.  
  86.   # When we say unicode_to_native we really mean ascii_to_native,
  87.   # which matters iff this is a non-ASCII platform (EBCDIC).
  88.  
  89.   return $name;
  90. }
  91.  
  92. sub B::IV::int_value {
  93.   my ($self) = @_;
  94.   return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
  95. }
  96.  
  97. sub B::NULL::as_string() {""}
  98. sub B::IV::as_string()   {goto &B::IV::int_value}
  99. sub B::PV::as_string()   {goto &B::PV::PV}
  100.  
  101. my $debug;
  102. my $op_count = 0;
  103. my @parents = ();
  104.  
  105. sub debug {
  106.     my ($class, $value) = @_;
  107.     $debug = $value;
  108.     walkoptree_debug($value);
  109. }
  110.  
  111. sub class {
  112.     my $obj = shift;
  113.     my $name = ref $obj;
  114.     $name =~ s/^.*:://;
  115.     return $name;
  116. }
  117.  
  118. sub parents { \@parents }
  119.  
  120. # For debugging
  121. sub peekop {
  122.     my $op = shift;
  123.     return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
  124. }
  125.  
  126. sub walkoptree_slow {
  127.     my($op, $method, $level) = @_;
  128.     $op_count++; # just for statistics
  129.     $level ||= 0;
  130.     warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
  131.     $op->$method($level) if $op->can($method);
  132.     if ($$op && ($op->flags & OPf_KIDS)) {
  133.     my $kid;
  134.     unshift(@parents, $op);
  135.     for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
  136.         walkoptree_slow($kid, $method, $level + 1);
  137.     }
  138.     shift @parents;
  139.     }
  140.     if (class($op) eq 'PMOP'
  141.     && ref($op->pmreplroot)
  142.     && ${$op->pmreplroot}
  143.     && $op->pmreplroot->isa( 'B::OP' ))
  144.     {
  145.     unshift(@parents, $op);
  146.     walkoptree_slow($op->pmreplroot, $method, $level + 1);
  147.     shift @parents;
  148.     }
  149. }
  150.  
  151. sub compile_stats {
  152.     return "Total number of OPs processed: $op_count\n";
  153. }
  154.  
  155. sub timing_info {
  156.     my ($sec, $min, $hr) = localtime;
  157.     my ($user, $sys) = times;
  158.     sprintf("%02d:%02d:%02d user=$user sys=$sys",
  159.         $hr, $min, $sec, $user, $sys);
  160. }
  161.  
  162. my %symtable;
  163.  
  164. sub clearsym {
  165.     %symtable = ();
  166. }
  167.  
  168. sub savesym {
  169.     my ($obj, $value) = @_;
  170. #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
  171.     $symtable{sprintf("sym_%x", $$obj)} = $value;
  172. }
  173.  
  174. sub objsym {
  175.     my $obj = shift;
  176.     return $symtable{sprintf("sym_%x", $$obj)};
  177. }
  178.  
  179. sub walkoptree_exec {
  180.     my ($op, $method, $level) = @_;
  181.     $level ||= 0;
  182.     my ($sym, $ppname);
  183.     my $prefix = "    " x $level;
  184.     for (; $$op; $op = $op->next) {
  185.     $sym = objsym($op);
  186.     if (defined($sym)) {
  187.         print $prefix, "goto $sym\n";
  188.         return;
  189.     }
  190.     savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
  191.     $op->$method($level);
  192.     $ppname = $op->name;
  193.     if ($ppname =~
  194.         /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
  195.     {
  196.         print $prefix, uc($1), " => {\n";
  197.         walkoptree_exec($op->other, $method, $level + 1);
  198.         print $prefix, "}\n";
  199.     } elsif ($ppname eq "match" || $ppname eq "subst") {
  200.         my $pmreplstart = $op->pmreplstart;
  201.         if ($$pmreplstart) {
  202.         print $prefix, "PMREPLSTART => {\n";
  203.         walkoptree_exec($pmreplstart, $method, $level + 1);
  204.         print $prefix, "}\n";
  205.         }
  206.     } elsif ($ppname eq "substcont") {
  207.         print $prefix, "SUBSTCONT => {\n";
  208.         walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
  209.         print $prefix, "}\n";
  210.         $op = $op->other;
  211.     } elsif ($ppname eq "enterloop") {
  212.         print $prefix, "REDO => {\n";
  213.         walkoptree_exec($op->redoop, $method, $level + 1);
  214.         print $prefix, "}\n", $prefix, "NEXT => {\n";
  215.         walkoptree_exec($op->nextop, $method, $level + 1);
  216.         print $prefix, "}\n", $prefix, "LAST => {\n";
  217.         walkoptree_exec($op->lastop,  $method, $level + 1);
  218.         print $prefix, "}\n";
  219.     } elsif ($ppname eq "subst") {
  220.         my $replstart = $op->pmreplstart;
  221.         if ($$replstart) {
  222.         print $prefix, "SUBST => {\n";
  223.         walkoptree_exec($replstart, $method, $level + 1);
  224.         print $prefix, "}\n";
  225.         }
  226.     }
  227.     }
  228. }
  229.  
  230. sub walksymtable {
  231.     my ($symref, $method, $recurse, $prefix) = @_;
  232.     my $sym;
  233.     my $ref;
  234.     my $fullname;
  235.     no strict 'refs';
  236.     $prefix = '' unless defined $prefix;
  237.     while (($sym, $ref) = each %$symref) {
  238.         $fullname = "*main::".$prefix.$sym;
  239.     if ($sym =~ /::$/) {
  240.         $sym = $prefix . $sym;
  241.         if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
  242.                walksymtable(\%$fullname, $method, $recurse, $sym);
  243.         }
  244.     } else {
  245.            svref_2object(\*$fullname)->$method();
  246.     }
  247.     }
  248. }
  249.  
  250. {
  251.     package B::Section;
  252.     my $output_fh;
  253.     my %sections;
  254.  
  255.     sub new {
  256.     my ($class, $section, $symtable, $default) = @_;
  257.     $output_fh ||= FileHandle->new_tmpfile;
  258.     my $obj = bless [-1, $section, $symtable, $default], $class;
  259.     $sections{$section} = $obj;
  260.     return $obj;
  261.     }
  262.  
  263.     sub get {
  264.     my ($class, $section) = @_;
  265.     return $sections{$section};
  266.     }
  267.  
  268.     sub add {
  269.     my $section = shift;
  270.     while (defined($_ = shift)) {
  271.         print $output_fh "$section->[1]\t$_\n";
  272.         $section->[0]++;
  273.     }
  274.     }
  275.  
  276.     sub index {
  277.     my $section = shift;
  278.     return $section->[0];
  279.     }
  280.  
  281.     sub name {
  282.     my $section = shift;
  283.     return $section->[1];
  284.     }
  285.  
  286.     sub symtable {
  287.     my $section = shift;
  288.     return $section->[2];
  289.     }
  290.  
  291.     sub default {
  292.     my $section = shift;
  293.     return $section->[3];
  294.     }
  295.  
  296.     sub output {
  297.     my ($section, $fh, $format) = @_;
  298.     my $name = $section->name;
  299.     my $sym = $section->symtable || {};
  300.     my $default = $section->default;
  301.  
  302.     seek($output_fh, 0, 0);
  303.     while (<$output_fh>) {
  304.         chomp;
  305.         s/^(.*?)\t//;
  306.         if ($1 eq $name) {
  307.         s{(s\\_[0-9a-f]+)} {
  308.             exists($sym->{$1}) ? $sym->{$1} : $default;
  309.         }ge;
  310.         printf $fh $format, $_;
  311.         }
  312.     }
  313.     }
  314. }
  315.  
  316. XSLoader::load 'B';
  317.  
  318. 1;
  319.  
  320. __END__
  321.  
  322.